home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / Wood / persistent-clos.lisp < prev    next >
Encoding:
Text File  |  1992-09-02  |  23.0 KB  |  511 lines  |  [TEXT/CCL2]
  1. ;;;-*- Mode: Lisp; Package: (WOOD) -*-
  2.  
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;;
  5. ;; persistent-clos.lisp
  6. ;; Support for saving/restoring CLOS instance to/from Wood persistent heaps.
  7. ;;
  8. ;; Copyright © 1992 Apple Computer, Inc. All rights reserved.
  9. ;; Permission is given to use, copy, and modify this software provided
  10. ;; that this copyright notice is attached to all derivative works.
  11. ;; This software is provided "as is". Apple makes no warranty or
  12. ;; representation, either express or implied, with respect to this software,
  13. ;; its quality, accuracy, merchantability, or fitness for a particular
  14. ;; purpose.
  15. ;;
  16.  
  17. ;;;;;;;;;;;;;;;;;;;;;;;;;;
  18. ;;
  19. ;; Modification History
  20. ;;
  21. ;; -------------- 0.5
  22. ;; 06/23/92 bill  New file
  23. ;;
  24.  
  25. (in-package :wood)
  26.  
  27. (defun dc-class-hash (disk-cache &optional create?)
  28.   (let ((res (dc-%svref disk-cache $root-vector $pheap.class-hash)))
  29.     (if (eql res $pheap-nil)
  30.       (if create?
  31.         (setf (dc-%svref disk-cache $root-vector $pheap.class-hash)
  32.               (dc-make-hash-table disk-cache)))
  33.       res)))
  34.  
  35. (defun p-find-class (pheap name &optional (errorp t))
  36.   (multiple-value-bind (pointer imm?) (%p-store-hash-key pheap name)
  37.     (when pointer
  38.       (let ((res (dc-find-class (pheap-disk-cache pheap) pointer imm? errorp)))
  39.         (when res (pptr pheap res))))))
  40.  
  41. (defun dc-find-class (disk-cache pointer immediate? &optional (errorp t))
  42.   (let ((hash (dc-class-hash disk-cache)))
  43.     (or (and hash
  44.              (dc-gethash disk-cache pointer immediate? hash))
  45.         (when errorp
  46.           (error "Class named ~s not found." 
  47.                  (dc-pointer-load disk-cache pointer immediate?))))))
  48.  
  49. ; Will overwrite an existing class
  50. (defun p-make-class (pheap name slots)
  51.   (unless (and (vectorp slots) (every 'symbolp slots))
  52.     (error "~s is not a vector of slot names"))
  53.   (multiple-value-bind (pointer imm?) (%p-store pheap name)
  54.     (pptr pheap
  55.           (dc-make-class (pheap-disk-cache pheap)
  56.                          pointer
  57.                          (%p-store pheap slots)
  58.                          imm?
  59.                          slots
  60.                          pheap))))
  61.  
  62. (defun dc-make-class (disk-cache name slots &optional name-imm? slots-object pheap)
  63.   (let* ((class (dc-make-uvector disk-cache $class-size $v_class))
  64.          (hash (dc-class-hash disk-cache t))
  65.          (wrapper (dc-make-class-wrapper disk-cache class slots slots-object pheap)))
  66.     (dc-%svfill disk-cache class
  67.       ($class.name name-imm?) name
  68.       $class.own-wrapper wrapper)
  69.     (dc-puthash disk-cache name name-imm? hash class)))
  70.  
  71. (defun dc-make-class-wrapper (disk-cache class slots &optional slots-object pheap)
  72.   (let ((wrapper (dc-make-vector disk-cache $wrapper-size)))
  73.     (dc-%svfill disk-cache wrapper
  74.       $wrapper.class class
  75.       $wrapper.slots slots)
  76.     (when slots-object
  77.       (setf (gethash slots-object
  78.                      (wrapper-hash (or pheap (disk-cache-pheap disk-cache))))
  79.             wrapper))
  80.     wrapper))
  81.  
  82. ; Access a (disk) class'es wrapper. Update it to agree with the
  83. ; class in memory, if there is one.
  84. ; Returns 2 value:
  85. ; 1) the (possibly new) wrapper
  86. ; 2) the in-memory class, or NIL if there isn't one.
  87. ; 3) the vector of slot names for the in-memory class, or NIL
  88. ; 4) true if the class'es was obsolete.
  89. (defun dc-update-class-wrapper (disk-cache class &optional pheap memory-class dont-update)
  90.   (unless pheap (setq pheap (disk-cache-pheap disk-cache)))
  91.   (if (eq memory-class :none)
  92.     (setq memory-class nil)
  93.     (let* ((name (pointer-load pheap (dc-%svref disk-cache class $class.name) :default disk-cache)))
  94.       (setq memory-class (find-class name nil))))
  95.   (let ((wrapper (dc-%svref disk-cache class $class.own-wrapper))
  96.         (obsolete? nil)
  97.         slot-names)
  98.     (when memory-class
  99.       (let ((wrapper-hash (wrapper-hash pheap)))
  100.         (setq slot-names (wood-slot-names-vector (class-prototype memory-class)))            
  101.         (unless (eql wrapper (gethash slot-names wrapper-hash))
  102.           (let ((old-slot-names (pointer-load pheap (dc-%svref disk-cache wrapper $wrapper.slots)
  103.                                               :default disk-cache)))
  104.             (if (equalp old-slot-names slot-names)
  105.               (setf (gethash slot-names wrapper-hash) wrapper)
  106.               (progn
  107.                 (setq obsolete? t)
  108.                 (unless dont-update
  109.                   (setf wrapper (dc-make-class-wrapper
  110.                                  disk-cache class
  111.                                  (%p-store pheap slot-names) slot-names pheap)
  112.                         (dc-%svref disk-cache class $class.own-wrapper) wrapper))))))))
  113.     (values wrapper memory-class slot-names obsolete?)))
  114.  
  115.  
  116. ; This knows internals of MCL's CLOS implementation
  117. (defun class-slots-vector (class)
  118.   (ccl::%wrapper-instance-slots
  119.    (or (ccl::%class-own-wrapper class)
  120.        (ccl::initialize-class-and-wrapper class))))
  121.  
  122. (defun dc-make-class-slots-vector (disk-cache class &optional
  123.                                               (pheap (disk-cache-pheap disk-cache)))
  124.   (%p-store pheap (wood-slot-names-vector (class-prototype class))))
  125.  
  126. (def-predicate ccl::classp (p disk-cache pointer)
  127.   (dc-vector-subtype-p disk-cache pointer $v_class))
  128.  
  129. (def-accessor class-name (p) (disk-cache pointer)
  130.   (require-satisfies dc-classp disk-cache pointer)
  131.   (dc-%svref disk-cache pointer $class.name))
  132.  
  133. (defun (setf dc-class-name) (value disk-cache class &optional value-imm?)
  134.   (require-satisfies dc-classp disk-cache class)
  135.   (setf (dc-%svref disk-cache class $class.name value-imm?) value)
  136.   (values value value-imm?))
  137.  
  138. (def-accessor class-own-wrapper (p) (disk-cache pointer)
  139.   (require-satisfies dc-classp disk-cache pointer)
  140.   (dc-%svref disk-cache pointer $class.own-wrapper))
  141.  
  142. (defun (setf dc-class-own-wrapper) (value disk-cache class &optional value-imm?)
  143.   (require-satisfies dc-classp disk-cache class)
  144.   (setf (dc-%svref disk-cache class $class.own-wrapper value-imm?) value)
  145.   (values value value-imm?))
  146.  
  147. (defmacro dc-wrapper-class (disk-cache wrapper)
  148.   `(dc-uvref ,disk-cache ,wrapper $wrapper.class))
  149.  
  150. (defmacro dc-wrapper-slots (disk-cache wrapper)
  151.   `(dc-uvref ,disk-cache ,wrapper $wrapper.slots))
  152.  
  153. (defmethod %p-store-object (pheap (object standard-class) descend)
  154.   (let* ((disk-cache (pheap-disk-cache pheap))
  155.          (descend (eq descend t))
  156.          name imm?
  157.          (address (maybe-cached-address pheap object
  158.                     (multiple-value-setq (name imm?)
  159.                       (%p-store pheap (class-name object)))
  160.                     (or (dc-find-class disk-cache name imm? nil)
  161.                         (progn
  162.                           (setq descend nil)
  163.                           (dc-make-class disk-cache
  164.                                          name
  165.                                          (dc-make-class-slots-vector
  166.                                           disk-cache object pheap)
  167.                                          imm?))))))
  168.     (when descend
  169.       (unless name
  170.         (multiple-value-setq (name imm?) (%p-store pheap (class-name object))))
  171.       (setf (dc-class-name disk-cache address imm?) name)
  172.       (setf (dc-wrapper-slots disk-cache (dc-class-own-wrapper disk-cache address))
  173.             (dc-make-class-slots-vector disk-cache object pheap)))
  174.     address))
  175.  
  176. (defun p-load-class (pheap disk-cache pointer depth subtype)
  177.   (declare (ignore depth subtype))
  178.   (maybe-cached-value pheap pointer
  179.     (multiple-value-bind (name-pointer imm?) (dc-class-name disk-cache pointer)
  180.       (let ((name (dc-pointer-load disk-cache name-pointer imm? pheap)))
  181.         (or (find-class name nil)
  182.             (let ((slots (pointer-load pheap
  183.                                        (dc-wrapper-slots
  184.                                         disk-cache
  185.                                         (dc-class-own-wrapper disk-cache pointer))
  186.                                        :default
  187.                                        disk-cache)))
  188.               (eval `(defclass ,name () ,(coerce slots 'list)))))))))    
  189.  
  190. (defmethod p-allocate-instance (pheap (class symbol))
  191.   (p-allocate-instance pheap (or (p-find-class pheap class nil)
  192.                                  (p-store pheap (find-class class)))))
  193.  
  194. (defmethod p-allocate-instance (pheap (class standard-class))
  195.   (p-%allocate-instance pheap (p-store pheap class) class))
  196.  
  197. (defmethod p-allocate-instance (pheap (class pptr))
  198.   (require-satisfies p-classp class)
  199.   (p-%allocate-instance pheap class nil))
  200.  
  201. (defun p-%allocate-instance (pheap class memory-class)
  202.   (pptr pheap (dc-%allocate-instance (pheap-disk-cache pheap) (pptr-pointer class) memory-class)))
  203.  
  204. (defun dc-%allocate-instance (disk-cache class &optional memory-class)
  205.   (let* ((wrapper (dc-update-class-wrapper disk-cache class nil memory-class))
  206.          (slots (dc-make-vector
  207.                  disk-cache
  208.                  (dc-length disk-cache (dc-wrapper-slots disk-cache wrapper))
  209.                  nil (%unbound-marker) t))
  210.          (res (dc-make-uvector disk-cache $instance-size $v_instance)))
  211.     (dc-%svfill disk-cache res
  212.       $instance.wrapper wrapper
  213.       $instance.slots slots)
  214.     res))
  215.  
  216. (def-predicate ccl::standard-instance-p (p disk-cache pointer)
  217.   (dc-vector-subtype-p disk-cache pointer $v_instance))
  218.  
  219. (def-accessor ccl::instance-class-wrapper (p) (disk-cache pointer)
  220.   (require-satisfies dc-standard-instance-p disk-cache pointer)
  221.   (dc-%svref disk-cache pointer $instance.wrapper))
  222.  
  223. ; This is the wrong name. Check the MOP
  224. (def-accessor instance-access (p index) (disk-cache pointer)
  225.   (require-satisfies dc-standard-instance-p disk-cache pointer)
  226.   (dc-uvref disk-cache (dc-%svref disk-cache pointer $instance.slots) index))
  227.  
  228. (defun (setf p-instance-access) (value p index)
  229.   (setq index (require-type index 'fixnum))
  230.   (if (pptr-p p)
  231.     (let ((pheap (pptr-pheap p)))
  232.       (multiple-value-bind (v imm?) (%p-store pheap value)
  233.         (setf (dc-instance-access
  234.                (pheap-disk-cache pheap) (pptr-pointer p) index imm?)
  235.               v)
  236.         (if imm? v (pptr pheap v))))
  237.     (error "~s is defined only for Wood instances" '(setf p-instance-access))))
  238.  
  239. (defun (setf dc-instance-access) (value disk-cache pointer index value-imm?)
  240.   (require-satisfies dc-standard-instance-p disk-cache pointer)
  241.   (setf (dc-uvref disk-cache (dc-%svref disk-cache pointer $instance.slots)
  242.                   index value-imm?)
  243.         value))
  244.  
  245. (defun instance-access (thing index)
  246.   (declare (ignore thing index))
  247.   (error "~s is defined only for Wood instances" 'instance-access))
  248.  
  249. ; Instance is an on-disk address.
  250. ; class is an in-memory class or NIL.
  251. ; Returns three values:
  252. ; 1) The slots vector on disk
  253. ; 2) The slot names vector in memory.
  254. ; 3) slot-names vector if the instance was obsolete.
  255. ;    This will be different from the second value if the
  256. ;    dont-update arg is true.
  257. ;
  258. ; This is hairy because it has to deal with a lot of possibilities:
  259. ;
  260. ; 1) Class exists in memory, but hasn't been associated with PHEAP yet.
  261. ; 2) Class exists in memeory and has been associated with PHEAP.
  262. ; 3) Class does not exist in memory.
  263. ; 4) 1 or 2 and the class has been redefined since the instance was stored in the PHEAP.
  264. (defun dc-updated-instance-slots (disk-cache instance memory-class pheap &optional
  265.                                              dont-update)
  266.   (let ((old-wrapper (dc-%svref disk-cache instance $instance.wrapper))
  267.         (instance-slots (dc-%svref disk-cache instance $instance.slots))
  268.         class wrapper slot-names old-slot-names obsolete?)
  269.     (if memory-class
  270.       (progn
  271.         (setq slot-names (wood-slot-names-vector (class-prototype memory-class)))
  272.         (setq wrapper (gethash slot-names (wrapper-hash pheap))))
  273.       (progn
  274.         (setq class (dc-%svref disk-cache old-wrapper $wrapper.class))
  275.         (multiple-value-setq (wrapper memory-class slot-names obsolete?)
  276.           (dc-update-class-wrapper disk-cache class pheap nil dont-update))
  277.         (unless slot-names
  278.           (setq slot-names (pointer-load pheap (dc-%svref disk-cache old-wrapper $wrapper.slots)
  279.                                          :default disk-cache)
  280.                 wrapper old-wrapper))))
  281.     (if (if (and wrapper (not obsolete?))
  282.           (eql wrapper old-wrapper)
  283.           (when (equalp slot-names
  284.                         (setq old-slot-names
  285.                               (pointer-load pheap (dc-%svref disk-cache old-wrapper $wrapper.slots)
  286.                                             :default disk-cache)))
  287.             (setq wrapper (setf (gethash slot-names (wrapper-hash pheap)) old-wrapper))))
  288.       ; Wrapper is current
  289.       (values instance-slots slot-names)
  290.       ; Wrapper needs updating.
  291.       (if dont-update
  292.         (values instance-slots old-slot-names slot-names)
  293.         (let* ((slot-count (length slot-names))
  294.                (slot-values (make-array slot-count))
  295.                (slot-imms (make-array slot-count)))
  296.           (declare (fixnum slot-count)
  297.                    (dynamic-extent slot-values slot-imms))
  298.           (unless old-slot-names
  299.             (setq old-wrapper (dc-%svref disk-cache instance $instance.wrapper)
  300.                   old-slot-names (pointer-load 
  301.                                   pheap
  302.                                   (dc-%svref disk-cache old-wrapper $wrapper.slots)
  303.                                   :default disk-cache)))
  304.           (unless wrapper
  305.             (let ((class (dc-%svref disk-cache old-wrapper $wrapper.class)))
  306.               (setq wrapper (dc-update-class-wrapper disk-cache class pheap memory-class dont-update))))
  307.           (dotimes (i slot-count)
  308.             (let ((index (position (svref slot-names i) old-slot-names :test 'eq)))
  309.               (if index
  310.                 (multiple-value-bind (value imm?) (dc-uvref disk-cache instance-slots index)
  311.                   (setf (svref slot-values i) value
  312.                         (svref slot-imms i) imm?))
  313.                 (setf (svref slot-values i) (%unbound-marker)
  314.                       (svref slot-imms i) t))))
  315.           (let* ((old-instance-length (dc-length disk-cache instance-slots))
  316.                  (new-instance-slots (if (>= old-instance-length slot-count)
  317.                                        (let ((index slot-count))
  318.                                          (dotimes (i (- old-instance-length slot-count))
  319.                                            (setf (dc-uvref disk-cache instance-slots index t)
  320.                                                  (%unbound-marker)))
  321.                                          instance-slots)
  322.                                        (dc-make-vector
  323.                                         disk-cache slot-count
  324.                                         (dc-area disk-cache instance-slots)
  325.                                         (%unbound-marker) t))))
  326.             (dotimes (i slot-count)
  327.               (let ((value (svref slot-values i))
  328.                     (imm? (svref slot-imms i)))
  329.                 (unless (and imm? (eq value (%unbound-marker)))
  330.                   (setf (dc-%svref disk-cache new-instance-slots i imm?) value))))
  331.             (setf (dc-%svref disk-cache instance $instance.wrapper) wrapper
  332.                   (dc-%svref disk-cache instance $instance.slots) new-instance-slots)
  333.             (values new-instance-slots slot-names t)))))))
  334.  
  335. (def-predicate ccl::standard-instance-p (p disk-cache pointer)
  336.   (and (dc-uvectorp disk-cache pointer)
  337.        (eq (dc-%vector-subtype disk-cache pointer) $v_instance)))
  338.  
  339. (def-accessor slot-value (p slot-name) (disk-cache pointer)
  340.   (require-satisfies dc-standard-instance-p disk-cache pointer)
  341.   (multiple-value-bind (value imm?)
  342.                        (dc-%slot-value disk-cache pointer slot-name)
  343.     (if (and imm? (eq value (%unbound-marker)))
  344.       (dc-slot-unbound disk-cache pointer slot-name)
  345.       (values value imm?))))
  346.  
  347. (defun dc-%slot-value (disk-cache pointer slot-name)
  348.   (multiple-value-bind (slots index)
  349.                        (dc-%slot-vector-and-index disk-cache pointer slot-name t)
  350.     (if slots
  351.       (if (eq slots (%unbound-marker))
  352.         (values slots t)
  353.         (dc-%svref disk-cache slots index))
  354.       (dc-slot-missing disk-cache pointer slot-name 'slot-value))))
  355.  
  356. (defun dc-slot-missing (disk-cache pointer slot-name operation &optional new-value)
  357.   (declare (ignore operation new-value))
  358.   (error "~s has no slot named ~s" 
  359.          (pptr (disk-cache-pheap disk-cache) pointer) slot-name))
  360.  
  361. (defun dc-slot-unbound (disk-cache pointer slot-name)
  362.   (error "Slot ~s is unbound in ~s"
  363.          slot-name (pptr (disk-cache-pheap disk-cache) pointer)))
  364.  
  365. ; Returns two values:
  366. ; 1) disk-cache vector of slots
  367. ; 2) index in the vector
  368. ;
  369. ; If the slot doesn't exist, returns NIL.
  370. ; If the slot exists, but only after the instance is updated and dont-update
  371. ; is true, returns (%unbound-marker).
  372. (defun dc-%slot-vector-and-index (disk-cache pointer slot-name &optional dont-update)
  373.   (let* ((pheap (disk-cache-pheap disk-cache))
  374.          (wrapper (dc-%svref disk-cache pointer $instance.wrapper))
  375.          (memory-class (pointer-load
  376.                         pheap
  377.                         (dc-%svref disk-cache
  378.                                    (dc-%svref disk-cache wrapper $wrapper.class)
  379.                                    $class.name)
  380.                         :default disk-cache)))
  381.     (multiple-value-bind (slots slot-names real-slot-names)
  382.                          (dc-updated-instance-slots
  383.                           disk-cache pointer
  384.                           (find-class
  385.                            memory-class
  386.                            nil)
  387.                           pheap
  388.                           dont-update)
  389.       (let ((index (position slot-name slot-names :test 'eq))
  390.             (real-index (and dont-update
  391.                              real-slot-names
  392.                              (position slot-name real-slot-names))))
  393.         (if (and index (or (not dont-update) (not real-slot-names) real-index))
  394.           (values slots index)
  395.           (if real-index
  396.             (%unbound-marker)
  397.             nil))))))
  398.  
  399. (defun (setf p-slot-value) (value p slot-name)
  400.   (if (pptr-p p)
  401.     (let* ((pheap (pptr-pheap p))
  402.            (disk-cache (pheap-disk-cache pheap))
  403.            (pointer (pptr-pointer p)))
  404.       (multiple-value-bind (slots index)
  405.                            (dc-%slot-vector-and-index disk-cache pointer slot-name)
  406.         (unless slots
  407.           (dc-slot-missing disk-cache pointer slot-name '(setf p-slot-value)))
  408.         (multiple-value-bind (v imm?) (%p-store pheap value)
  409.           (setf (dc-%svref disk-cache slots index imm?) v)
  410.           (if imm?
  411.             v
  412.             (pptr pheap v)))))))
  413.  
  414. (def-accessor slot-boundp (p slot-name) (disk-cache pointer)
  415.   (values (not (eq (dc-%slot-value disk-cache pointer slot-name)
  416.                    (%unbound-marker)))
  417.           t))
  418.  
  419. (def-accessor slot-makunbound (p slot-name) (disk-cache pointer)
  420.   (multiple-value-bind (slots index)
  421.                        (dc-%slot-vector-and-index disk-cache pointer slot-name t)
  422.     (unless slots
  423.       (dc-slot-missing disk-cache pointer slot-name 'p-slot-makunbound))
  424.     (unless (eq slots (%unbound-marker))
  425.       (setf (dc-%svref disk-cache slots index t) (%unbound-marker)))
  426.     pointer))
  427.  
  428. (defmethod %p-store-object (pheap (object ccl::funcallable-standard-object) descend)
  429.   (declare (ignore pheap descend))
  430.   (error "Can't save generic functions yet. Maybe never."))
  431.  
  432. ; this will do the wrong thing if anyone redefines the class
  433. ; of the object while it is running.
  434. (defmethod %p-store-object (pheap (object standard-object) descend)
  435.   (let* ((class (class-of object)))
  436.     (%p-store-object-body (pheap object descend disk-cache address)
  437.       (dc-%allocate-instance disk-cache (%p-store pheap class))
  438.       (multiple-value-bind (slots slot-names)
  439.                            (dc-updated-instance-slots disk-cache address class pheap)
  440.         (dotimes (i (length slot-names))
  441.           (let ((slot-name (svref slot-names i)))
  442.             (multiple-value-bind (value imm?)
  443.                                  (if (slot-boundp object slot-name)
  444.                                    (%p-store pheap (wood-slot-value object slot-name) descend)
  445.                                    (values (%unbound-marker) t))
  446.               (setf (dc-uvref disk-cache slots i imm?) value))))))))
  447.  
  448. (defun p-load-instance (pheap disk-cache pointer depth subtype)
  449.   (declare (ignore subtype))
  450.   (let* ((cached? t)
  451.          class
  452.          (instance (maybe-cached-value pheap pointer
  453.                      (setq cached? nil)
  454.                      (if (null depth)
  455.                        (return-from p-load-instance (pptr pheap pointer)))
  456.                      (setq class (pointer-load pheap
  457.                                                (dc-%svref disk-cache
  458.                                                           (dc-instance-class-wrapper
  459.                                                            disk-cache pointer)
  460.                                                           $wrapper.class)
  461.                                                :default
  462.                                                disk-cache))
  463.                      (allocate-instance class))))
  464.     (when (or (not cached?)
  465.               (and (eq depth t)
  466.                    (let ((p-load-hash (p-load-hash pheap)))
  467.                      (unless (gethash instance p-load-hash)
  468.                        (setf (gethash instance p-load-hash) instance)))))
  469.       (let ((next-level-depth (cond ((or (eq depth :single) (fixnump depth)) nil)
  470.                                     (t depth))))
  471.         (multiple-value-bind (slot-vector slot-names real-slot-names)
  472.                              (dc-updated-instance-slots
  473.                               disk-cache pointer class pheap t)
  474.           (dotimes (i (length slot-names))
  475.             (let ((slot-name (svref slot-names i)))
  476.               (when (or (null real-slot-names) (position slot-name real-slot-names))
  477.                 (multiple-value-bind (pointer immediate?)
  478.                                      (dc-%svref disk-cache slot-vector i)
  479.                   (if immediate?
  480.                     (if (eq pointer (%unbound-marker))
  481.                       (slot-makunbound instance slot-name)
  482.                       (setf (wood-slot-value instance slot-name) pointer))
  483.                     (setf (wood-slot-value instance slot-name)
  484.                           (pointer-load pheap pointer next-level-depth disk-cache)))))))
  485.           (when real-slot-names
  486.             (dotimes (i (length real-slot-names))
  487.               (let ((slot-name (svref real-slot-names i)))
  488.                 (unless (position slot-name slot-names)
  489.                   (slot-makunbound instance slot-name))))))))
  490.     instance))
  491.  
  492. ; These methods allow users to specialize the way that CLOS instances are saved.
  493.  
  494. ; Return a vector of the names of the slots to be saved for an instance.
  495. ; The instance saving code assumes that multiple calls to this
  496. ; method will return the same (EQ) vector unless the class has been redefined.
  497. ; May be called with a CLASS-PROTOTYPE, so don't expect any of the slots
  498. ; to contain useful information.
  499. (defmethod wood-slot-names-vector ((object standard-object))
  500.   (class-slots-vector (class-of object)))
  501.  
  502. ; These allow specialization of slot-value.
  503. ; Some slots may want to be saved in a different format,
  504. ; or interned on the way back in.
  505. (defmethod wood-slot-value ((object standard-object) slot-name)
  506.   (slot-value object slot-name))
  507.  
  508. (defmethod (setf wood-slot-value) (value (object standard-object) slot-name)
  509.   (setf (slot-value object slot-name) value))
  510.   
  511.